Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH12/SRC/OBJSOL1.CLS

Text File | 1996-04-04 | 12.9 KB | 496 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ObjSolid"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

' These ObjPolygon objects are the oriented faces.
Public Faces As New Collection
Public Convex As Boolean
Public MaxZ As Single
' ***********************************************
' Clip faces.
' ***********************************************
Public Sub ClipEye(r As Single)
Dim obj As Object

    For Each obj In Faces
        obj.ClipEye r
    Next obj
End Sub

' ************************************************
' Return the distance from this solid to a point.
' ************************************************
Property Get Distance(x As Single, y As Single, Z As Single) As Single
Dim best As Single
Dim dist As Single
Dim i As Integer

    best = INFINITY
    For i = 1 To Faces.Count
        dist = Faces(i).Distance(x, y, Z)
        If best > dist Then best = dist
    Next i
    Distance = best
End Property

' ************************************************
' Compute and save the maximum Z value.
' ************************************************
Public Sub SetZmax()
Dim best As Single
Dim Z As Single
Dim i As Integer

    best = -INFINITY
    For i = 1 To Faces.Count
        If Not Faces(i).Culled Then
            Z = Faces(i).zmax
            If best < Z Then best = Z
        End If
    Next i
    MaxZ = best
End Sub

' ***********************************************
' Create faces to make a pyramid of height L with
' base given by the coord array.
' ***********************************************
Sub Stellate(L As Single, ParamArray coord() As Variant)
Dim x0 As Single
Dim y0 As Single
Dim z0 As Single
Dim x1 As Single
Dim y1 As Single
Dim z1 As Single
Dim x2 As Single
Dim y2 As Single
Dim z2 As Single
Dim x3 As Single
Dim y3 As Single
Dim z3 As Single
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim Bx As Single
Dim By As Single
Dim Bz As Single
Dim nx As Single
Dim ny As Single
Dim nz As Single
Dim num As Integer
Dim i As Integer
Dim pt As Integer

    num = (UBound(coord) + 1) \ 3
    If num < 3 Then
        Beep
        MsgBox "Must have at least 3 points to stellate.", , vbExclamation
        Exit Sub
    End If

    ' (x0, y0, z0) is the center of the polygon.
    x0 = 0
    y0 = 0
    z0 = 0
    pt = 0
    For i = 1 To num
        x0 = x0 + coord(pt)
        y0 = y0 + coord(pt + 1)
        z0 = z0 + coord(pt + 2)
        pt = pt + 3
    Next i
    x0 = x0 / num
    y0 = y0 / num
    z0 = z0 / num

    ' Find the normal.
    x1 = coord(0)
    y1 = coord(1)
    z1 = coord(2)
    x2 = coord(3)
    y2 = coord(4)
    z2 = coord(5)
    x3 = coord(6)
    y3 = coord(7)
    z3 = coord(8)
    Ax = x2 - x1
    Ay = y2 - y1
    Az = z2 - z1
    Bx = x3 - x2
    By = y3 - y2
    Bz = z3 - z2
    m3Cross nx, ny, nz, Ax, Ay, Az, Bx, By, Bz

    ' Give the normal length L.
    m3SizeVector L, nx, ny, nz

    ' The normal + <x0, y0, z0> gives the point.
    x0 = x0 + nx
    y0 = y0 + ny
    z0 = z0 + nz

    ' Build the triangles that make up the solid.
    x1 = coord(3 * num - 3)
    y1 = coord(3 * num - 2)
    z1 = coord(3 * num - 1)
    pt = 0
    For i = 1 To num
        x2 = coord(pt)
        y2 = coord(pt + 1)
        z2 = coord(pt + 2)
        AddFace x1, y1, z1, x2, y2, z2, x0, y0, z0
        x1 = x2
        y1 = y2
        z1 = z2
        pt = pt + 3
    Next i
End Sub

' ***********************************************
' Add apolygon to the solid.
' ***********************************************
Public Sub AddPolygon(pgon As Object)
    Faces.Add pgon
End Sub

' ***********************************************
' Add an oriented face to the solid.
' ***********************************************
Public Sub AddFace(ParamArray coord() As Variant)
Dim pgon As ObjPolygon
Dim num As Integer
Dim pt As Integer
Dim i As Integer

    num = (UBound(coord) + 1) \ 3
    If num < 3 Then
        Beep
        MsgBox "Faces in a Solid must contain at least 3 points.", , vbExclamation
        Exit Sub
    End If

    Set pgon = New ObjPolygon
    Faces.Add pgon

    pt = 0
    For i = 1 To num
        pgon.AddPoint (coord(pt)), (coord(pt + 1)), (coord(pt + 2))
        pt = pt + 3
    Next i
End Sub


' ************************************************
' Perform backface removal on the faces.
' ************************************************
Public Sub Cull(x As Single, y As Single, Z As Single)
Dim obj As Object

    For Each obj In Faces
        obj.Cull x, y, Z
    Next obj
End Sub
' ***********************************************
' Create normals for polygon objects.
' ***********************************************
Sub CreateNormal(Objects As Collection)
Dim obj As Object

    For Each obj In Faces
        obj.CreateNormal Objects
    Next obj
End Sub

' ***********************************************
' Set or clear the Culled property for all faces.
' ***********************************************
Property Let Culled(value As Boolean)
Dim obj As Object

    For Each obj In Faces
        obj.Culled = value
    Next obj
End Property



' ***********************************************
' Return a string indicating the object type.
' ***********************************************
Property Get ObjectType() As String
    ObjectType = "SOLID"
End Property


' ************************************************
' Draw the object into a metafile.
' ************************************************
Public Sub MakeWMF(mhdc As Integer)
Dim obj As Object

    For Each obj In Faces
        obj.MakeWMF mhdc
    Next obj
End Sub

' ***********************************************
' Fix the data coordinates at their transformed
' values.
' ***********************************************
Public Sub FixPoints()
Dim obj As Object

    For Each obj In Faces
        obj.FixPoints
    Next obj
End Sub

' ************************************************
' Apply a transformation matrix which may not
' contain 0, 0, 0, 1 in the last column to the
' object.
' ************************************************
Public Sub ApplyFull(M() As Single)
Dim obj As Object

    For Each obj In Faces
        obj.ApplyFull M
    Next obj
End Sub

' ************************************************
' Apply a transformation matrix to the object.
' ************************************************
Public Sub Apply(M() As Single)
Dim obj As Object

    For Each obj In Faces
        obj.Apply M
    Next obj
End Sub


' ************************************************
' Apply a nonlinear transformation.
' ************************************************
Public Sub Distort(D As Object)
Dim obj As Object

    For Each obj In Faces
        obj.Distort D
    Next obj
End Sub

' ************************************************
' Write a polyline to a file using Write.
' Begin with "SOLID" to identify this object.
' ************************************************
Public Sub FileWrite(filenum As Integer)
Dim obj As Object

    Write #filenum, "SOLID", Convex, Faces.Count

    For Each obj In Faces
        obj.FileWrite filenum
    Next obj
End Sub

' ************************************************
' Order the faces of the solid with those with
' smallest transformed Z coordinates first.
'
' As we switch faces around, we keep track of the
' number of switches we have made. If it clear we
' are stuck in an infinite loop, just move the
' first face to the ordered collection so we can
' continue.
' ************************************************
Public Sub OrderFaces()
Dim ordered As New Collection
Dim obj1 As ObjPolygon
Dim obji As ObjPolygon
Dim i As Integer
Dim xmin As Single
Dim xmax As Single
Dim ymin As Single
Dim ymax As Single
Dim zmin As Single
Dim zmax As Single
Dim xmini As Single
Dim xmaxi As Single
Dim ymini As Single
Dim ymaxi As Single
Dim zmini As Single
Dim zmaxi As Single
Dim overlap As Boolean
Dim switches As Integer
Dim max_switches As Integer

    ' Pull out any that are culled.
    i = 1
    Do While i <= Faces.Count
        If Faces.Item(i).Culled Then
            ordered.Add Faces.Item(i)
            Faces.Remove i
        Else
            i = i + 1
        End If
    Loop

    ' Order the remaining faces.
    max_switches = Faces.Count
    Do While Faces.Count > 0
        ' Get item 1's extent.
        Set obj1 = Faces.Item(1)
        obj1.GetExtent xmin, xmax, ymin, ymax, zmin, zmax

        ' Compare this face to the others.
        overlap = False     ' In case Face.Count = 0.
        For i = 2 To Faces.Count
            Set obji = Faces.Item(i)

            ' Get item i's extent.
            obji.GetExtent xmini, xmaxi, ymini, ymaxi, zmini, zmaxi

            overlap = True
            If xmaxi <= xmin Or _
               xmini >= xmax Or _
               ymaxi <= ymin Or _
               ymini >= ymax Or _
               zmini >= zmax Then
                ' The extents do not overlap.
                overlap = False
            ElseIf obji.IsAbove(obj1) Then
                ' Face i is all above the plane
                ' of face 1.
                overlap = False
            ElseIf obj1.IsBelow(obji) Then
                ' Face 1 is all beneath the plane
                ' of face i.
                overlap = False
            ElseIf Not obj1.Obscures(obji) Then
                ' If obj1 does not lie partly above
                ' obji, then there is no problem.
                overlap = False
            End If

            If overlap Then Exit For
        Next i

        If overlap And switches < max_switches Then
            ' There's overlap, move face i to the
            ' top of the list.
            Faces.Remove i
            Faces.Add obji, , 1 ' Before position 1.
            switches = switches + 1
        Else
            ' There's no overlap. Move face 1 to
            ' the ordered collection.
            ordered.Add obj1
            Faces.Remove 1
            max_switches = Faces.Count
            switches = 0
        End If
    Loop ' Loop until we've ordered all the faces.

    ' Replace the Faces collection with the
    ' ordered collection.
    Set Faces = ordered
End Sub

' ************************************************
' Draw the transformed solid on a Form, Printer,
' or PictureBox. Draw the faces in depth-sort
' order using polygon shading.
' ************************************************
Public Sub DrawShaded(canvas As Object, Optional r As Variant)
Dim obj As Object

    ' If it's not convex, order the faces.
    If Not Convex Then OrderFaces

    ' Draw the faces in order.
    For Each obj In Faces
        obj.DrawShaded canvas, r
    Next obj
End Sub



' ************************************************
' Draw the transformed solid on a Form, Printer,
' or PictureBox. Draw the faces in depth-sort
' order.
' ************************************************
Public Sub DrawOrdered(canvas As Object, Optional r As Variant)
Dim obj As Object

    ' If it's not convex, order the faces.
    If Not Convex Then OrderFaces

    ' Draw the faces in order.
    For Each obj In Faces
        obj.DrawOrdered canvas, r
    Next obj
End Sub


' ************************************************
' Draw the transformed solid on a Form, Printer,
' or PictureBox.
' ************************************************
Public Sub Draw(canvas As Object, Optional r As Variant)
Dim obj As Object

    For Each obj In Faces
        obj.Draw canvas, r
    Next obj
End Sub

' ************************************************
' Read a polyline from a file using Input.
' Assume the "SOLID" label has already been
' read.
' ************************************************
Public Sub FileInput(filenum As Integer)
Dim num As Integer
Dim i As Integer
Dim obj As Object
Dim obj_type As String

    ' Read the number of faces in the solid.
    Input #filenum, Convex, num

    ' Read faces from the file.
    For i = 1 To num
        Input #filenum, obj_type
        Select Case obj_type
            Case "SOLID"
                Set obj = New ObjSolid
            Case "POLYGON"
                Set obj = New ObjPolygon
            Case Else
                Beep
                MsgBox "Invalid Solid sub-object type """ & obj_type & """.", , vbExclamation
                Exit Sub
        End Select
        obj.FileInput filenum
        Faces.Add obj
    Next i
End Sub


' ***********************************************
' Return the maximum transformed Z value for this
' object. Note that you must call SetZmax first
' to set the maximum Z value.
' ***********************************************
Property Get zmax() As Single
    zmax = MaxZ
End Property